home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #2 / Monster Media No. 2 (Monster Media)(1994).ISO / soundu / dg2.zip / DG.BAS < prev    next >
BASIC Source File  |  1994-05-09  |  47KB  |  1,512 lines
  1. DEFINT A-Z
  2. DECLARE SUB MakeMidi ()
  3. DECLARE FUNCTION VLen$ (i&)
  4. DECLARE FUNCTION mki2$ (i%)
  5. DECLARE FUNCTION mkl2$ (l&)
  6. DECLARE SUB WriteTrack (name$, data$, fhand%)
  7. DECLARE FUNCTION words (text$)
  8. DECLARE FUNCTION BuildChord$ (croot, ctype)
  9. DECLARE FUNCTION GetNotes$ (starttime, endtime)
  10. DECLARE FUNCTION GetWord$ (orig$, wordno)
  11. DECLARE FUNCTION Modify (initial, change, irlo, irhi, degree)
  12. DECLARE FUNCTION Note2Num (note$)
  13. DECLARE FUNCTION Num2Note$ (number)
  14. DECLARE FUNCTION Round$ (initial$, newnote1$, scaletype, size)
  15. DECLARE FUNCTION ScaleNum (initial, irlo, irhi, orlo, orhi, inv)
  16. DECLARE FUNCTION Trim$ (orig$)
  17. DECLARE SUB Arpeg ()
  18. DECLARE SUB ViewComp ()
  19. DECLARE SUB Life ()
  20. DECLARE SUB Quit ()
  21. DECLARE SUB Add ()
  22. DECLARE SUB Load ()
  23. DECLARE SUB Save ()
  24. DECLARE SUB Cellular ()
  25. DECLARE SUB Move ()
  26. DECLARE SUB DeleteNotes ()
  27. DECLARE SUB SaveText (filename$)
  28. DECLARE SUB RandomNotes ()
  29. DECLARE SUB Generate ()
  30. DECLARE SUB Wave ()
  31. DECLARE SUB Mountain ()
  32.  
  33. COMMON SHARED notes()
  34. DIM SHARED notes(1 TO 11, 1 TO 3, 0 TO 500)
  35.  
  36.  
  37. 'how notes are stored:
  38. '  (1) they are stored in the notes array,
  39. '  (2) notes has three subscripts:
  40. '      (a) 1 to 11:  specifies channel number
  41. '      (b) 1 to 2:   1 is the note's time location,
  42. '                    2 is the note frequency number
  43. '                    3 is the note duration
  44. '      (c) 1 to 500: are the notes themselves,
  45. '                    0 is the top note number
  46.  
  47. 'when notes are added, check to if they go before any notes that are
  48. 'already present. if so, move those notes first so that the whole array
  49. 'stays in order.
  50.  
  51.     FOR r = 1 TO 11
  52.         notes(r, 1, 0) = 0
  53.     NEXT
  54.  
  55. start:
  56.     CLS
  57.     PRINT "Dilaudid Glide"
  58.     PRINT "Music Authoring System"
  59.     PRINT STRING$(80, "-")
  60.     PRINT
  61.     PRINT " 1. View composition"
  62.     PRINT " 2. Add notes"
  63.     PRINT " 3. Generate pattern"
  64.     PRINT " 4. Delete notes"
  65.     PRINT " 5. Move notes"
  66.     PRINT
  67.     PRINT " 6. Load sequence"
  68.     PRINT " 7. Save sequence"
  69.     PRINT " 8. Save text"
  70.     PRINT " 9. Save MIDI (std file format 1)"
  71.     PRINT "10. Quit"
  72.     PRINT
  73.     LINE INPUT "-->", x$
  74.  
  75.     sel = VAL(x$)
  76.     SELECT CASE sel
  77.         CASE 1  'view composition
  78.             ViewComp
  79.         CASE 2  'add notes
  80.             Add
  81.         CASE 3  'generate pattern
  82.             Generate
  83.         CASE 4  'delete notes
  84.             DeleteNotes
  85.         CASE 5  'move notes
  86.             Move
  87.         CASE 6  'load sequence
  88.             Load
  89.         CASE 7  'save sequence
  90.             Save
  91.         CASE 8  'save as text
  92.             SaveText ""
  93.         CASE 9  'save as midi
  94.             MakeMidi
  95.         CASE 10 'quit
  96.             Quit
  97.     END SELECT
  98.     GOTO start
  99.  
  100. SUB Add
  101.     'Add a section of notes
  102.  
  103.     CLS
  104.     PRINT "Dilaudid Glide"
  105.     PRINT "Music Authoring System             (  X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
  106.     PRINT STRING$(80, "-")
  107.     PRINT ".NOT files are text note lists, .CEL files are binary information lists"
  108.     PRINT
  109.  
  110.     x$ = DIR$("*.CEL")
  111.     IF x$ <> "" THEN
  112.         PRINT x$,
  113.         DO
  114.             x$ = DIR$
  115.             IF x$ = "" THEN EXIT DO
  116.             PRINT x$,
  117.         LOOP
  118.     END IF
  119.     x$ = DIR$("*.NOT")
  120.     IF x$ <> "" THEN
  121.         PRINT x$,
  122.         DO
  123.             x$ = DIR$
  124.             IF x$ = "" THEN EXIT DO
  125.             PRINT x$,
  126.         LOOP
  127.     END IF
  128.  
  129.     PRINT
  130.     PRINT
  131.     LINE INPUT "Channel # ---------->", channel$
  132.     LINE INPUT "Main filename ------>", filename$
  133.     IF UCASE$(RIGHT$("   " + filename$, 3)) <> "NOT" THEN
  134.         LINE INPUT "Note range start --->", notestart$
  135.         LINE INPUT "Note range end ----->", noteend$
  136.     ELSE
  137.         notestart$ = "C": noteend$ = "c"
  138.     END IF
  139.         '   SCALE TYPES
  140.         '   -----------
  141.     PRINT "    '0=chromatic"
  142.     PRINT "    '1=whole tone starting on C"
  143.     PRINT "    '2=whole tone starting on C+"
  144.     PRINT "    '3=diatonic/c-major"
  145.     PRINT "    '4=spooky"
  146.     PRINT "    '5=black keys"
  147.     PRINT "    '6=indian"
  148.     PRINT "    '7=spooky/more dissonant"
  149.     LINE INPUT "Scale type (0-6) --->", scaletype$
  150.     scaletype = VAL(scaletype$)
  151.     LINE INPUT "Rounding buffer ---->", size$
  152.     size = VAL(size$)
  153.     LINE INPUT "Spacing style (ox) ->", spacing$
  154.     IF spacing$ = "" THEN
  155.         LINE INPUT "Note length (16ths)->", notelen$
  156.         notelen = VAL(notelen$)
  157.     ELSE
  158.         LINE INPUT "Spacing repeats ---->", spacerep$
  159.     END IF
  160.     LINE INPUT "Time place start --->", timestart$
  161.     timestart = ((VAL(timestart$) - 1) * 16) + 1
  162.     IF timestart = 0 THEN timestart = 1
  163.     IF spacing$ = "" THEN
  164.         LINE INPUT "Time length -------->", timelen$
  165.         timelen = VAL(timelen$) * 16
  166.     END IF
  167.     LINE INPUT "# repeats ---------->", repeats$
  168.     repeats = VAL(repeats$)
  169.     IF repeats = 0 THEN repeats = 1
  170.     LINE INPUT "Degree variation --->", degreev$
  171.     degreev = VAL(degreev$)
  172.     LINE INPUT "Repeat filename ---->", rfilename$
  173.     PRINT
  174.     LINE INPUT "Proceed? (y/N) ----->", x$
  175.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  176.  
  177.     channel = VAL(channel$)
  178.     IF channel < 1 THEN channel = 1
  179.     IF channel > 11 THEN channel = 11
  180.     notestart = Note2Num(notestart$)
  181.     noteend = Note2Num(noteend$)
  182.  
  183.     'get number of notes / repeated section
  184.  
  185.     IF spacing$ <> "" THEN
  186.         spacing$ = Trim$(spacing$)
  187.         numnotesb = words(spacing$)
  188.         spacerep = VAL(spacerep$)
  189.         numnotes = spacerep * numnotesb
  190.     ELSE
  191.         numnotes = timelen / notelen
  192.     END IF
  193.     REDIM temp(numnotes)
  194.  
  195.     'load and scale notes
  196.         IF UCASE$(RIGHT$(filename$, 3)) = "NOT" THEN
  197.             OPEN filename$ FOR BINARY AS #1
  198.             FOR r = 1 TO numnotes
  199.                 x$ = ""
  200.                 DO
  201.                     x$ = x$ + INPUT$(1, #1)
  202.                     IF EOF(1) THEN EXIT DO
  203.                     IF RIGHT$(x$, 1) = " " THEN EXIT DO
  204.                 LOOP
  205.                 temp(r) = Note2Num(Trim$(x$))
  206.             NEXT
  207.         ELSE
  208.             OPEN filename$ FOR BINARY AS #1
  209.             FOR r = 1 TO numnotes
  210.                 IF LOC(1) = LOF(1) THEN SEEK #1, 1
  211.                 init = ASC(INPUT$(1, #1))
  212.                 temp(r) = ScaleNum(init, 0, 255, notestart, noteend, 0)
  213.             NEXT
  214.         END IF
  215.     CLOSE
  216.  
  217.     'do repeat loop, copying notes to main array
  218.     IF rfilename$ <> "" THEN
  219.         varying = 1
  220.         OPEN rfilename$ FOR BINARY AS #1
  221.     ELSE
  222.         varying = 0
  223.     END IF
  224.     countnotes = 0
  225.     r1 = timestart
  226.     FOR r = 1 TO repeats
  227.         FOR n = 1 TO numnotes
  228.             PRINT ".";
  229.             IF varying THEN
  230.                 vary = ASC(INPUT$(1, #1))
  231.                 note = Modify(temp(n), vary, 0, 255, degreev)
  232.             ELSE
  233.                 note = temp(n)
  234.             END IF
  235.             IF spacing$ = "" THEN
  236.                 r1 = ((r - 1) * numnotes * notelen) + ((n - 1) * notelen) + timestart
  237.             ELSE
  238.                 notelen = LEN(GetWord$(spacing$, ((n - 1) MOD numnotesb) + 1))
  239.             END IF
  240.             r2 = r1 + (notelen - 1)
  241.             rnotes$ = GetNotes$(r1, r2)
  242.             note = Note2Num(Round$(rnotes$, Num2Note$(note), scaletype, size))
  243.             IF spacing$ <> "" THEN
  244.                 IF INSTR(GetWord$(spacing$, ((n - 1) MOD numnotesb) + 1), "o") THEN note = 0
  245.             END IF
  246.             IF note <> 0 THEN
  247.                 countnotes = countnotes + 1
  248.                 al = notes(channel, 1, 0) + countnotes
  249.                 notes(channel, 1, al) = r1
  250.                 notes(channel, 2, al) = note
  251.                 notes(channel, 3, al) = notelen
  252.             END IF
  253.             r1 = r1 + notelen
  254.         NEXT
  255.     NEXT
  256.     notes(channel, 1, 0) = notes(channel, 1, 0) + countnotes
  257.     IF rfilename$ <> "" THEN
  258.         CLOSE
  259.     END IF
  260.     
  261.     ERASE temp
  262. END SUB
  263.  
  264. SUB Arpeg
  265.     CLS
  266.     REDIM as$(3 TO 9)
  267.     PRINT "Dilaudid Glide"
  268.     PRINT "Music Authoring System             (  X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
  269.     PRINT STRING$(80, "-")
  270.     PRINT
  271.     LINE INPUT "Chord sequence ----->", chords$
  272.     IF INSTR(chords$, "3") THEN LINE INPUT "Arpeggio style 3rd ->", as$(3)
  273.     IF INSTR(chords$, "4") THEN LINE INPUT "Arpeggio style 4th ->", as$(4)
  274.     IF INSTR(chords$, "5") THEN LINE INPUT "Arpeggio style 5th ->", as$(5)
  275.     IF INSTR(chords$, "7") THEN LINE INPUT "Arpeggio style 7th ->", as$(7)
  276.     IF INSTR(chords$, "9") THEN LINE INPUT "Arpeggio style 9th ->", as$(9)
  277.     LINE INPUT "Filename (8 chars) ->", filename$
  278.     PRINT
  279.     LINE INPUT "Proceed? (y/N) ----->", x$
  280.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN ERASE as$: EXIT SUB
  281.     IF filename$ = "" THEN ERASE as$: EXIT SUB
  282.     filename$ = filename$ + ".NOT"
  283.  
  284.     numchords = words(chords$)
  285.  
  286.     OPEN filename$ FOR OUTPUT AS #1
  287.  
  288.     FOR c = 1 TO numchords
  289.         PRINT ".";
  290.         chord$ = GetWord(chords$, c)
  291.         ctype = VAL(RIGHT$(chord$, 1))
  292.         croot = Note2Num(MID$(chord$, 1, LEN(chord$) - 1))
  293.         chord$ = BuildChord$(croot, ctype)
  294.         numnotes = words(as$(ctype))
  295.         FOR n = 1 TO numnotes
  296.             PRINT #1, GetWord$(chord$, VAL(GetWord$(as$(ctype), n))) + " ";
  297.         NEXT
  298.     NEXT
  299.  
  300.     CLOSE
  301.     ERASE as$
  302.  
  303. END SUB
  304.  
  305. FUNCTION BuildChord$ (croot, ctype)
  306.     temp$ = ""
  307.  
  308.     SELECT CASE ctype
  309.         CASE 4
  310.             temp$ = Num2Note$(croot + 0) + " "
  311.             temp$ = temp$ + Num2Note$(croot + 5) + " "
  312.             temp$ = temp$ + Num2Note$(croot + 11) + " "
  313.             temp$ = temp$ + Num2Note$(croot + 16)
  314.         CASE 3, 5, 7, 9
  315.             n = 2 + ((ctype - 3) / 2)
  316.             temp$ = Num2Note$(croot) + " "
  317.             temp$ = temp$ + Num2Note$(croot + 4) + " "
  318.             temp$ = temp$ + Num2Note$(croot + 7) + " "
  319.             IF ctype > 3 THEN temp$ = temp$ + Num2Note$(croot + 11) + " "
  320.             IF ctype > 5 THEN temp$ = temp$ + Num2Note$(croot + 14) + " "
  321.             IF ctype > 7 THEN temp$ = temp$ + Num2Note$(croot + 17)
  322.         END SELECT
  323.  
  324.     BuildChord$ = Trim$(temp$)
  325. END FUNCTION
  326.  
  327. SUB Cellular
  328.     'do a cellular automata generation
  329.  
  330.     CLS
  331.     PRINT "Dilaudid Glide"
  332.     PRINT "Music Authoring System"
  333.     PRINT STRING$(80, "-")
  334.     PRINT
  335.     LINE INPUT "K1 (1-10,2) --------->", k1$
  336.     LINE INPUT "K2 (1-10,3) --------->", k2$
  337.     LINE INPUT "Spd (1-20,4) -------->", spd$
  338.     LINE INPUT "Row start (1-35) ---->", row1$
  339.     LINE INPUT "Number of rows ------>", norow$
  340.     LINE INPUT "Col start (1-35) ---->", col1$
  341.     LINE INPUT "number of cols ------>", nocol$
  342.     LINE INPUT "Time start ---------->", time1$
  343.     LINE INPUT "Duration ------------>", duration$
  344.     LINE INPUT "Random seed --------->", seed$
  345.     LINE INPUT "Output filename (8) ->", filename$
  346.     PRINT
  347.     LINE INPUT "Proceed? (y/N) ----->", x$
  348.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  349.     IF filename$ = "" THEN EXIT SUB
  350.     
  351.     k1 = VAL(k1$)
  352.     k2 = VAL(k2$)
  353.     g = VAL(spd$)   'infection rate
  354.     out$ = filename$ + ".CEL"
  355.     sx = VAL(row1$)
  356.     ex = sx + VAL(norow$) - 1
  357.     sy = VAL(col1$)
  358.     ey = sx + VAL(nocol$) - 1
  359.     time1 = VAL(time1$)
  360.     time2 = time1 + VAL(duration$) - 1
  361.     RANDOMIZE VAL(seed$)
  362.  
  363.     REDIM array1(0 TO 36, 0 TO 36)
  364.     REDIM array2(0 TO 36, 0 TO 36)
  365.  
  366.     FOR r = 1 TO 35
  367.         FOR c = 1 TO 35
  368.             array1(r, c) = (INT(RND * 254))
  369.         NEXT
  370.     NEXT
  371.  
  372.     SCREEN 13
  373.  
  374.     OUT &H3C8, 1
  375.  
  376.     FOR r = 1 TO 127
  377.         OUT &H3C9, (r * 127) \ 254
  378.         OUT &H3C9, 0
  379.         OUT &H3C9, 63 - (r * 127) \ 254
  380.     NEXT
  381.     FOR r = 128 TO 254
  382.         OUT &H3C9, 63 - ((r - 127) * 127) \ 254
  383.         OUT &H3C9, 0
  384.         OUT &H3C9, 0
  385.     NEXT
  386.  
  387.     DEF SEG = &HA000
  388.  
  389.     FOR c = 1 TO 254
  390.         POKE (199 * 320) + c, c
  391.     NEXT
  392.  
  393.     IF out$ <> "" THEN OPEN out$ FOR OUTPUT AS #1
  394.  
  395.     timeat = 0
  396.  
  397.     DO
  398.         timeat = timeat + 1
  399.         IF out$ <> "" AND timeat >= time1 THEN
  400.             FOR r = sx TO ex
  401.                 FOR c = sy TO ey
  402.                     PRINT #1, CHR$((array1(r, c)) + 1);
  403.                 NEXT
  404.             NEXT
  405.         END IF
  406.  
  407.         FOR r = 1 TO 35
  408.             FOR c = 1 TO 35
  409.                 POKE (r * 320) + c, (array1(r, c)) + 1
  410.                 array2(r, c) = array1(r, c)
  411.             NEXT
  412.         NEXT
  413.  
  414.         LINE (sx - 1, sy - 1)-(ex + 1, ey + 1), 0, B
  415.  
  416.         FOR r = 1 TO 35
  417.             FOR c = 1 TO 35
  418.                 IF (array2(r, c)) = 254 THEN           'ill cells
  419.                     array1(r, c) = (0)
  420.                 ELSEIF (array2(r, c)) = 0 THEN       'healthy cells
  421.                     aa = 0: bb = 0
  422.                     IF (array2(r + 1, c)) > 0 AND (array2(r + 1, c)) < 254 THEN aa = 1 ELSE IF (array2(r + 1, c)) = 254 THEN bb = 1
  423.                     IF (array2(r - 1, c)) > 0 AND (array2(r - 1, c)) < 254 THEN aa = aa + 1 ELSE IF (array2(r - 1, c)) = 254 THEN bb = bb + 1
  424.                     IF (array2(r, c + 1)) > 0 AND (array2(r, c + 1)) < 254 THEN aa = aa + 1 ELSE IF (array2(r, c + 1)) = 254 THEN bb = bb + 1
  425.                     IF (array2(r, c - 1)) > 0 AND (array2(r, c - 1)) < 254 THEN aa = aa + 1 ELSE IF (array2(r, c - 1)) = 254 THEN bb = bb + 1
  426.                     array1(r, c) = ((aa \ k1) + (bb \ k2))
  427.                 ELSE                                    'infected cells
  428.                     aa = 0: ss = 0
  429.                     IF (array2(r + 1, c)) > 0 AND (array2(r + 1, c)) < 254 THEN aa = aa + 1: ss = ss + (array2(r + 1, c))
  430.                     IF (array2(r - 1, c)) > 0 AND (array2(r - 1, c)) < 254 THEN aa = aa + 1: ss = ss + (array2(r - 1, c))
  431.                     IF (array2(r, c + 1)) > 0 AND (array2(r, c + 1)) < 254 THEN aa = aa + 1: ss = ss + (array2(r, c + 1))
  432.                     IF (array2(r, c - 1)) > 0 AND (array2(r, c - 1)) < 254 THEN aa = aa + 1: ss = ss + (array2(r, c - 1))
  433.                     IF aa = 0 THEN
  434.                         array1(r, c) = array2(r, c)
  435.                     ELSE
  436.                         array1(r, c) = ((ss \ aa) + g)
  437.                     END IF
  438.                 END IF
  439.                 IF (array1(r, c)) > 254 THEN array1(r, c) = (254)
  440.             NEXT
  441.         NEXT
  442.     LOOP UNTIL timeat > time2
  443.  
  444.     IF out$ <> "" THEN CLOSE
  445.     SCREEN 0
  446.     WIDTH 80
  447.  
  448.     ERASE array1, array2
  449. END SUB
  450.  
  451. SUB DeleteNotes
  452.     'Delete a section of notes
  453.  
  454.     CLS
  455.     PRINT "Dilaudid Glide"
  456.     PRINT "Music Authoring System"
  457.     PRINT STRING$(80, "-")
  458.     PRINT
  459.     LINE INPUT "Channel # ---------->", channel$
  460.     PRINT
  461.     LINE INPUT "Proceed? (y/N) ----->", x$
  462.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  463.  
  464.     channel = VAL(channel$)
  465.     IF channel < 1 THEN channel = 1
  466.     IF channel > 11 THEN channel = 11
  467.  
  468.     'reset topnote
  469.     notes(channel, 1, 0) = 0
  470. END SUB
  471.  
  472. SUB Generate
  473.     CLS
  474.     PRINT "Dilaudid Glide"
  475.     PRINT "Music Authoring System             (  X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
  476.     PRINT STRING$(80, "-")
  477.     PRINT
  478.     PRINT "1. Cellular"
  479.     PRINT "2. Wave"
  480.     PRINT "3. Random"
  481.     PRINT "4. Mountain range"
  482.     PRINT "5. Life simulation"
  483.     PRINT "6. Arpeggiator"
  484.     PRINT
  485.     LINE INPUT "-->", x$
  486.  
  487.     sel = VAL(x$)
  488.     SELECT CASE sel
  489.         CASE 1  'cellular
  490.             Cellular
  491.         CASE 2  'wave
  492.             Wave
  493.         CASE 3  'random
  494.             RandomNotes
  495.         CASE 4  'mountain range
  496.             Mountain
  497.         CASE 5  'life
  498.             Life
  499.         CASE 6  'Arpeggiator
  500.             Arpeg
  501.     END SELECT
  502. END SUB
  503.  
  504. FUNCTION GetNotes$ (starttime, endtime)
  505.     'Figure out what notes are playing in a specific period of time
  506.  
  507.     FOR chan = 1 TO 11
  508.         top = notes(chan, 1, 0)
  509.         IF top > 0 THEN
  510.             FOR at = 1 TO top
  511.                 timeloc = notes(chan, 1, at)
  512.                 duration = notes(chan, 3, at)
  513.                 noteend = timeloc + (duration - 1)
  514.                 IF (starttime <= timeloc AND endtime >= timeloc) OR (starttime <= noteend AND endtime >= noteend) THEN
  515.                     note$ = note$ + Num2Note(notes(chan, 2, at)) + " "
  516.                 ELSE
  517.                     IF timeloc > endtime THEN EXIT FOR
  518.                 END IF
  519.             NEXT
  520.         END IF
  521.     NEXT
  522.     GetNotes$ = Trim$(note$)
  523. END FUNCTION
  524.  
  525. FUNCTION GetWord$ (orig$, wordno)
  526.     'Get a word from a sentance
  527.  
  528.     IF wordno = 1 THEN
  529.         x = INSTR(orig$, " ")
  530.         IF x = 0 THEN
  531.             t$ = orig$
  532.         ELSE
  533.             t$ = MID$(orig$, 1, x - 1)
  534.         END IF
  535.     ELSE
  536.         t$ = orig$
  537.         at = 2
  538.         DO
  539.             x = INSTR(t$, " ")
  540.             IF x = 0 THEN
  541.                 t$ = ""
  542.                 EXIT DO
  543.             ELSE
  544.                 t$ = MID$(t$, x + 1)
  545.                 IF at = wordno THEN
  546.                     x = INSTR(t$, " ")
  547.                     IF x <> 0 THEN
  548.                         t$ = MID$(t$, 1, x - 1)
  549.                     END IF
  550.                     EXIT DO
  551.                 END IF
  552.             END IF
  553.             at = at + 1
  554.         LOOP
  555.     END IF
  556.     GetWord$ = t$
  557. END FUNCTION
  558.  
  559. SUB Life
  560.     CLS
  561.     PRINT "Dilaudid Glide"
  562.     PRINT "Music Authoring System"
  563.     PRINT STRING$(80, "-")
  564.     PRINT
  565.     LINE INPUT "Row start (1-35) ---->", row1$
  566.     LINE INPUT "Number of rows ------>", norow$
  567.     LINE INPUT "Col start (1-35) ---->", col1$
  568.     LINE INPUT "number of cols ------>", nocol$
  569.     LINE INPUT "Time start ---------->", time1$
  570.     LINE INPUT "Duration ------------>", duration$
  571.     LINE INPUT "Random seed --------->", seed$
  572.     LINE INPUT "Output filename (8) ->", filename$
  573.     PRINT
  574.     LINE INPUT "Proceed? (y/N) ----->", x$
  575.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  576.     IF filename$ = "" THEN EXIT SUB
  577.  
  578.     out$ = filename$ + ".CEL"
  579.     sx = VAL(row1$)
  580.     ex = sx + VAL(norow$) - 1
  581.     sy = VAL(col1$)
  582.     ey = sx + VAL(nocol$) - 1
  583.     time1 = VAL(time1$)
  584.     time2 = time1 + VAL(duration$) - 1
  585.     RANDOMIZE VAL(seed$)
  586.     
  587.     REDIM array1(1 TO 35, 1 TO 35)
  588.     REDIM array2(1 TO 35, 1 TO 35)
  589.     
  590.     SCREEN 13
  591.     CLS
  592.     FOR r = 1 TO 35
  593.         FOR t = 1 TO 35
  594.             x = RND * 256
  595.             array1(r, t) = x
  596.         NEXT
  597.     NEXT
  598.  
  599.     OUT &H3C8, 1
  600.  
  601.     FOR r = 1 TO 127
  602.         OUT &H3C9, (r * 127) \ 254
  603.         OUT &H3C9, 0
  604.         OUT &H3C9, 63 - (r * 127) \ 254
  605.     NEXT
  606.     FOR r = 128 TO 254
  607.         OUT &H3C9, 63 - ((r - 127) * 127) \ 254
  608.         OUT &H3C9, 0
  609.         OUT &H3C9, 0
  610.     NEXT
  611.  
  612.     DEF SEG = &HA000
  613.  
  614.     IF out$ <> "" THEN OPEN out$ FOR OUTPUT AS #1
  615.  
  616.     timeat = 0
  617.  
  618.     DO
  619.         FOR r = 1 TO 35
  620.             FOR t = 1 TO 35
  621.                 orig = array1(r, t)
  622.                 ab = r - 1: IF ab = 0 THEN ab = 35
  623.                 bl = r + 1: IF bl = 36 THEN bl = 1
  624.                 lt = t + 1: IF lt = 36 THEN lt = 1
  625.                 rt = t - 1: IF rt = 0 THEN rt = 35
  626.                 avgn = (array1(ab, t) + array1(bl, t) + array1(r, lt) + array1(r, rt)) \ 4
  627.                 IF orig < 251 AND orig > 9 THEN
  628.                     SELECT CASE avgn
  629.                         CASE IS > 230
  630.                             orig = orig \ 3 + avgn \ 2
  631.                         CASE 80 TO 229
  632.                             orig = (orig * 2 + avgn) \ 3
  633.                         CASE ELSE
  634.                             orig = (orig + avgn * 2) \ 3
  635.                     END SELECT
  636.                 END IF
  637.                 IF orig > 130 THEN orig = orig + 4 ELSE orig = orig - 2
  638.                 IF orig <= 0 THEN orig = 255
  639.                 IF orig > 255 THEN orig = 255
  640.                 IF orig < 10 THEN
  641.                     array1(r, lt) = ((array1(r, lt) + 44) + array1(ab, lt)) \ 2
  642.                     IF array1(r, lt) > 255 THEN array1(r, lt) = 255
  643.                     array1(r, rt) = ((array1(r, rt) + 44) + array1(ab, rt)) \ 2
  644.                     IF array1(r, rt) > 255 THEN array1(r, rt) = 255
  645.                     array2(r, rt) = array1(r, rt)
  646.                     array2(r, lt) = array1(r, lt)
  647.                 END IF
  648.                 IF orig > 250 THEN
  649.                     array1(ab, t) = ((array1(ab, t) \ 3) + array1(ab, lt)) \ 2
  650.                     array1(bl, t) = ((array1(bl, t) \ 3) + array1(bl, lt)) \ 2
  651.                     array2(ab, t) = array1(ab, t)
  652.                     array2(bl, t) = array1(bl, t)
  653.                 END IF
  654.                 array2(r, t) = orig
  655.             NEXT
  656.         NEXT
  657.  
  658.         FOR r = 1 TO 35
  659.             FOR c = 1 TO 35
  660.                 'POKE (r * 320) + c, (array2(r, c)) + 1
  661.                 PSET (c, r), (array2(r, c)) + 1
  662.                 array1(r, c) = array2(r, c)
  663.             NEXT
  664.         NEXT
  665.  
  666.         LINE (sx - 1, sy - 1)-(ex + 1, ey + 1), 0, B
  667.  
  668.         timeat = timeat + 1
  669.         IF out$ <> "" AND timeat >= time1 THEN
  670.             FOR r = sx TO ex
  671.                 FOR c = sy TO ey
  672.                     PRINT #1, CHR$((array1(r, c)));
  673.                 NEXT
  674.             NEXT
  675.         END IF
  676.     LOOP UNTIL timeat > time2
  677.  
  678.     SCREEN 0
  679.     WIDTH 80
  680.  
  681.     CLOSE
  682.     ERASE array1, array2
  683.  
  684. END SUB
  685.  
  686. SUB Load
  687.     'Load a sequence array
  688.     x$ = DIR$("*.DGS")
  689.     IF x$ <> "" THEN
  690.         PRINT x$,
  691.         DO
  692.             x$ = DIR$
  693.             IF x$ = "" THEN EXIT DO
  694.             PRINT x$,
  695.         LOOP
  696.     END IF
  697.     PRINT
  698.     
  699.     LINE INPUT "Filename (8 chars) -->", filename$
  700.     filename$ = Trim$(filename$)
  701.     IF filename$ = "" THEN EXIT SUB
  702.     LINE INPUT "Are you sure (y/N) -->", x$
  703.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  704.     filename$ = filename$ + ".DGS"
  705.     OPEN filename$ FOR BINARY AS #1
  706.         FOR r1 = 1 TO 11
  707.             PRINT ".";
  708.             FOR r2 = 1 TO 3
  709.                 FOR r3 = 0 TO 500
  710.                     notes(r1, r2, r3) = CVI(INPUT$(2, #1))
  711.                 NEXT
  712.             NEXT
  713.         NEXT
  714.     CLOSE #1
  715. END SUB
  716.  
  717. SUB MakeMidi
  718.     'Save the sequence array
  719.     x$ = DIR$("*.MID")
  720.     IF x$ <> "" THEN
  721.         PRINT x$,
  722.         DO
  723.             x$ = DIR$
  724.             IF x$ = "" THEN EXIT DO
  725.             PRINT x$,
  726.         LOOP
  727.     END IF
  728.     PRINT
  729.  
  730.     LINE INPUT "Filename (8 chars) -->", file$
  731.     file$ = Trim$(file$)
  732.     IF file$ = "" THEN EXIT SUB
  733.     file$ = file$ + ".MID"
  734.  
  735.     OPEN file$ FOR OUTPUT AS #1
  736.  
  737.         '-------(1) Write header-----------------------
  738.         PRINT #1, "MThd" + mkl2$(6&);               'header, 6 bytes info
  739.         PRINT #1, CHR$(0) + CHR$(1);                'type 1 midi file
  740.         PRINT #1, mki2$(12);                        '11 tracks + Info
  741.         PRINT #1, mki2$(96);                        '96 ticks/quarter note
  742.         PRINT "Header..."
  743.  
  744.         PRINT "Master Track..."
  745.         name$ = "Dilaudid Glide"
  746.         data$ = CHR$(0) + CHR$(&HFF) + CHR$(&H58) + CHR$(&H4) + CHR$(&H4)
  747.         data$ = data$ + CHR$(&H2) + CHR$(&H18) + CHR$(&H8) + CHR$(0)
  748.         data$ = data$ + CHR$(&HFF) + CHR$(&H51) + CHR$(&H3) + CHR$(&H7)
  749.         data$ = data$ + CHR$(&HA1) + CHR$(&H20)
  750.         WriteTrack name$, data$, 1
  751.  
  752.         '-------(3) Write music tracks-----------------
  753.         FOR r = 1 TO 11
  754.             name$ = LTRIM$(RTRIM$(STR$(r)))
  755.             name$ = "Track " + name$
  756.             PRINT name$ + "..."
  757.  
  758.             data$ = ""
  759.  
  760.             '----create data$-------------------------
  761.             LastEnd& = 0                                    'Pt. of last end note
  762.             FOR nn = 1 TO notes(r, 1, 0)
  763.                 Dstart& = (notes(r, 1, nn) - 1) - LastEnd&          'delta note start
  764.                 LastEnd& = (notes(r, 1, nn) - 1) + notes(r, 3, nn)  'set new last end
  765.                 DeltaL& = notes(r, 3, nn)                   'set delta time length
  766.                 Dstart& = Dstart& * 24                      'convert delta start
  767.                 DeltaL& = DeltaL& * 24                      'convert delta length
  768.                 Nfreq = notes(r, 2, nn)
  769.                 
  770.                 Non$ = VLen$(Nstart&) + CHR$(&H90 + r) + CHR$(Nfreq) + CHR$(&H40)  'note on, chan R, freq NFreq, vel 64
  771.                 Noff$ = VLen$(DeltaL&) + CHR$(&H80 + r) + CHR$(Nfreq) + CHR$(&H64) 'note off, "   ",  "     "  ,  " 100
  772.  
  773.                 data$ = data$ + Non$ + Noff$
  774.             NEXT
  775.  
  776.             WriteTrack name$, data$, 1
  777.  
  778.         NEXT
  779.  
  780.     CLOSE #1
  781.  
  782. END SUB
  783.  
  784. FUNCTION mki2$ (i%)
  785.     x$ = MKI$(i%)
  786.     mki2$ = MID$(x$, 2, 1) + MID$(x$, 1, 1)
  787. END FUNCTION
  788.  
  789. FUNCTION mkl2$ (l&)
  790.     x$ = MKL$(l&)
  791.     mkl2$ = MID$(x$, 4, 1) + MID$(x$, 3, 1) + MID$(x$, 2, 1) + MID$(x$, 1, 1)
  792. END FUNCTION
  793.  
  794. FUNCTION Modify (initial, change, irlo, irhi, degree)
  795.     'takes a note INITIAL, and a CHANGE value in the
  796.     'range IRLO-IRHI, and modifies INITIAL up to DEGREE
  797.     'steps
  798.  
  799.     top = (irhi - irlo) / 2
  800.     temp = (change - irlo) - top    'from - to + range
  801.     chng = (temp / top) * degree    'calculate change
  802.  
  803.     Modify = initial + chng
  804.  
  805. END FUNCTION
  806.  
  807. SUB Mountain
  808.     'generate a mountain range pattern
  809.  
  810.     CLS
  811.     PRINT "Dilaudid Glide"
  812.     PRINT "Music Authoring System"
  813.     PRINT STRING$(80, "-")
  814.     PRINT
  815.     LINE INPUT "% conjunct jumps ---------->", conjunct$
  816.     LINE INPUT "% disjunct jumps ---------->", disjunct$
  817.     conjunct = VAL(conjunct$)
  818.     disjunct = VAL(disjunct$)
  819.     nonjunct = 100 - (conjunct + disjunct)
  820.     PRINT "% 'nonjunct' jumps -------->"; Trim$(STR$(nonjunct))
  821.     LINE INPUT "Conjunct jump size -------->", consize$
  822.     LINE INPUT "Disjunct jump size -------->", dissize$
  823.     consize = VAL(consize$)
  824.     dissize = VAL(dissize$)
  825.     LINE INPUT "Number of pattern buffers ->", nobuf$
  826.     nobuf = VAL(nobuf$)
  827.     IF nobuf THEN
  828.         LINE INPUT "Max size of buffer -------->", maxsize$
  829.         DIM patbuf(1 TO nobuf, -4 TO VAL(maxsize$))
  830.                 '-4 = relative (-1=note,else=start pt)
  831.                 '-3 = size
  832.                 '-2 = start rec chance
  833.                 '-1 = start play size
  834.                 ' 0 = beat lock
  835.         FOR r = 1 TO nobuf
  836.             PRINT "==BUFFFER " + Trim$(STR$(r)) + "=="
  837.             LINE INPUT "   Buffer size ------------>", size$
  838.             LINE INPUT "   Relative/Absolute (ra) ->", relabs$
  839.             LINE INPUT "   Start record chance ---->", src$
  840.             LINE INPUT "   Start play chance ------>", scpc$
  841.             LINE INPUT "   Beat lock -------------->", bl$
  842.             IF MID$(LCASE$(relabs$), 1, 1) = "r" THEN patbuf(r, -4) = -1 ELSE patbuf(r, -4) = (RND * 128) + 64
  843.             patbuf(r, -3) = VAL(size$)
  844.             patbuf(r, -2) = VAL(src$)
  845.             patbuf(r, -1) = VAL(scpc$)
  846.             patbuf(r, 0) = VAL(bl$)
  847.         NEXT
  848.     END IF
  849.     LINE INPUT "Seed ---------------------->", seed$
  850.     RANDOMIZE VAL(seed$)
  851.     LINE INPUT "Length -------------------->", length$
  852.     length = VAL(length$)
  853.     LINE INPUT "Filename (8 chars) -------->", filename$
  854.     PRINT
  855.     LINE INPUT "Proceed? (y/N) ------------>", x$
  856.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  857.     IF filename$ = "" THEN EXIT SUB
  858.     filename$ = filename$ + ".CEL"
  859.  
  860.     dir = RND * 2: pb = 0: pbloc = 0: pbbuf = 0
  861.     note = 128: rec = 0: recloc = 0: recbuf = 0
  862.  
  863.     SCREEN 12
  864.  
  865.     OPEN filename$ FOR OUTPUT AS #1
  866.  
  867.     FOR r = 1 TO nobuf  'fill pattern buffers first
  868.         dir = RND * 2
  869.         FOR t = 1 TO patbuf(r, -3)
  870.             x = (RND * 100) + 1
  871.             SELECT CASE x
  872.                 CASE 1 TO conjunct  'conjunct
  873.                     change = RND * consize
  874.                 CASE (conjunct + 1) TO (disjunct + conjunct + 1)    'disjunct
  875.                     change = RND * dissize
  876.                     IF dir THEN dir = 0 ELSE dir = 1
  877.                 CASE ELSE           'nonjunct
  878.                     change = 0
  879.             END SELECT
  880.             IF dir = 0 THEN change = -change
  881.             patbuf(r, t) = change
  882.         NEXT
  883.     NEXT
  884.  
  885.     FOR r = 1 TO length
  886.         IF pb THEN
  887.             change = patbuf(pbbuf, pbloc)
  888.             pbloc = pbloc + 1
  889.             IF pbloc > patbuf(pbbuf, -3) THEN
  890.                 pb = 0: pbloc = 0: pbbuf = 0
  891.             END IF
  892.         ELSE
  893.             x = (RND * 100) + 1
  894.             SELECT CASE x
  895.                 CASE 1 TO conjunct  'conjunct
  896.                     change = RND * consize
  897.                 CASE (conjunct + 1) TO (disjunct + conjunct + 1)    'disjunct
  898.                     change = RND * dissize
  899.                     IF dir THEN dir = 0 ELSE dir = 1
  900.                 CASE ELSE           'nonjunct
  901.                     change = 0
  902.             END SELECT
  903.             IF dir = 0 THEN change = -change
  904.             FOR t = 1 TO nobuf
  905.                 B = (r + 1) MOD patbuf(t, 0)
  906.                 IF B = 0 AND recbuf <> t THEN
  907.                     IF (RND * 100) < patbuf(t, -2) THEN
  908.                         rec = 1: recbuf = t: recloc = 1
  909.                         IF patbuf(t, -4) > -1 THEN
  910.                             patbuf(t, -4) = note
  911.                         END IF
  912.                         EXIT FOR
  913.                     END IF
  914.                 END IF
  915.             NEXT
  916.         END IF
  917.         note = note + change
  918.         IF note > 255 THEN note = 255
  919.         IF note < 0 THEN note = 0
  920.         PRINT #1, CHR$(note);
  921.         LINE (r MOD 640, 0)-(r MOD 640, 255), 0
  922.         PSET (r MOD 640, note), 15
  923.  
  924.         IF rec THEN
  925.             patbuf(recbuf, recloc) = change
  926.             recloc = recloc + 1
  927.             IF recloc > patbuf(recbuf, -3) THEN
  928.                 rec = 0: recloc = 0: recbuf = 0
  929.             END IF
  930.         ELSE
  931.             FOR t = 1 TO nobuf
  932.                 B = (r + 1) MOD patbuf(t, 0)
  933.                 IF B = 0 AND pbbuf <> t THEN
  934.                     IF (RND * 100) < patbuf(t, -1) THEN
  935.                         pb = 1: pbbuf = t: pbloc = 1
  936.                         IF patbuf(t, -4) > -1 THEN
  937.                             note = patbuf(t, -4)
  938.                         END IF
  939.                         EXIT FOR
  940.                     END IF
  941.                 END IF
  942.             NEXT
  943.         END IF
  944.     NEXT
  945.     CLOSE #1
  946.     LOCATE 30, 1
  947.     PRINT "--Press any key to return to menu--";
  948.  
  949.     DO UNTIL INKEY$ <> "": LOOP
  950.     SCREEN 0
  951. END SUB
  952.  
  953. SUB Move
  954.     'Delete a section of notes
  955.  
  956.     CLS
  957.     PRINT "Dilaudid Glide"
  958.     PRINT "Music Authoring System"
  959.     PRINT STRING$(80, "-")
  960.     PRINT
  961.     LINE INPUT "Channel # (0=ALL) -->", channel$
  962.     LINE INPUT "Distance ----------->", dist$
  963.     PRINT
  964.     LINE INPUT "Proceed? (y/N) ----->", x$
  965.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  966.  
  967.     c = VAL(channel$)
  968.     d = VAL(dist$) * 16
  969.     IF c = 0 THEN
  970.         c1 = 1: c2 = 11
  971.     ELSE
  972.         c1 = c: c2 = c
  973.     END IF
  974.  
  975.     FOR c = c1 TO c2
  976.         PRINT ".";
  977.         nn = notes(c, 1, 0)
  978.         FOR n = 1 TO nn
  979.             notes(c, 1, n) = notes(c, 1, n) + d
  980.         NEXT
  981.     NEXT
  982.  
  983. END SUB
  984.  
  985. FUNCTION Note2Num (note$)
  986.     'converts a note string into a number 0-127
  987.     'note names range X: X" X' X x x' x" x: x; x= x*
  988.     'note number 60 is middle C (c')
  989.     
  990.     SELECT CASE LCASE$(MID$(note$, 1, 1))
  991.         CASE "c"
  992.             basen = 0
  993.         CASE "d"
  994.             basen = 2
  995.         CASE "e"
  996.             basen = 4
  997.         CASE "f"
  998.             basen = 5
  999.         CASE "g"
  1000.             basen = 7
  1001.         CASE "a"
  1002.             basen = 9
  1003.         CASE "b"
  1004.             basen = 11
  1005.         CASE ELSE
  1006.             Note2Num = 0
  1007.             EXIT FUNCTION
  1008.     END SELECT
  1009.     IF INSTR(note$, "+") THEN basen = basen + 1
  1010.  
  1011.     IF ASC(MID$(note$, 1, 1)) < 75 THEN
  1012.         SELECT CASE RIGHT$(note$, 1)
  1013.             CASE ":"
  1014.                 octave = 0
  1015.             CASE CHR$(34)
  1016.                 octave = 1
  1017.             CASE "'"
  1018.                 octave = 2
  1019.             CASE ELSE
  1020.                 octave = 3
  1021.         END SELECT
  1022.     ELSE
  1023.         SELECT CASE RIGHT$(note$, 1)
  1024.             CASE "'"
  1025.                 octave = 5
  1026.             CASE CHR$(34)
  1027.                 octave = 6
  1028.             CASE ":"
  1029.                 octave = 7
  1030.             CASE ";"
  1031.                 octave = 8
  1032.             CASE "="
  1033.                 octave = 9
  1034.             CASE "*"
  1035.                 octave = 10
  1036.             CASE ELSE
  1037.                 octave = 4
  1038.         END SELECT
  1039.     END IF
  1040.  
  1041.     Note2Num = (octave * 12) + basen
  1042.  
  1043. END FUNCTION
  1044.  
  1045. FUNCTION Num2Note$ (number)
  1046.     'converts a number 0-127 into a note name string
  1047.     'note names range X: X" X' X x x' x" x: x; x= x*
  1048.     'note number 60 is middle C (c')
  1049.  
  1050.     uc = 0      'upper case toggle
  1051.     foot$ = ""  'footer
  1052.     SELECT CASE number
  1053.         CASE 0 TO 11    '   C: to B:
  1054.             uc = 1: foot$ = ":"
  1055.         CASE 12 TO 23   '   C" to B"
  1056.             uc = 1: foot$ = CHR$(34)
  1057.         CASE 24 TO 35   '   C' to B'
  1058.             uc = 1: foot$ = "'"
  1059.         CASE 36 TO 47   '   C to B
  1060.             uc = 1
  1061.         CASE 48 TO 59   '   c to b
  1062.         CASE 60 TO 71   '   c' to b'
  1063.             foot$ = "'"
  1064.         CASE 72 TO 83   '   c" to b"
  1065.             foot$ = CHR$(34)
  1066.         CASE 84 TO 95   '   c: to b:
  1067.             foot$ = ":"
  1068.         CASE 96 TO 107  '   c; to b;
  1069.             foot$ = ";"
  1070.         CASE 108 TO 119 '   c= to b=
  1071.             foot$ = "="
  1072.         CASE 120 TO 127 '   c* to g*
  1073.             foot$ = "*"
  1074.     END SELECT
  1075.     SELECT CASE (number MOD 12)
  1076.         CASE 0
  1077.             note$ = "c"
  1078.         CASE 1
  1079.             note$ = "c+"
  1080.         CASE 2
  1081.             note$ = "d"
  1082.         CASE 3
  1083.             note$ = "d+"
  1084.         CASE 4
  1085.             note$ = "e"
  1086.         CASE 5
  1087.             note$ = "f"
  1088.         CASE 6
  1089.             note$ = "f+"
  1090.         CASE 7
  1091.             note$ = "g"
  1092.         CASE 8
  1093.             note$ = "g+"
  1094.         CASE 9
  1095.             note$ = "a"
  1096.         CASE 10
  1097.             note$ = "a+"
  1098.         CASE 11
  1099.             note$ = "b"
  1100.     END SELECT
  1101.     IF uc = 1 THEN note$ = UCASE$(note$)
  1102.     Num2Note$ = note$ + foot$
  1103. END FUNCTION
  1104.  
  1105. SUB Quit
  1106.     'Quit program
  1107.  
  1108.     LINE INPUT "Are you sure (y/N) -->", x$
  1109.     IF LCASE$(LEFT$(x$, 1)) = "y" THEN
  1110.         CLS
  1111.         END
  1112.     END IF
  1113. END SUB
  1114.  
  1115. SUB RandomNotes
  1116.     CLS
  1117.     PRINT "Dilaudid Glide"
  1118.     PRINT "Music Authoring System             (  X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
  1119.     PRINT STRING$(80, "-")
  1120.     PRINT
  1121.     LINE INPUT "Number of notes ---->", numnotes$
  1122.     LINE INPUT "Seed --------------->", seed$
  1123.     LINE INPUT "Filename (8 chars) ->", filename$
  1124.     PRINT
  1125.     LINE INPUT "Proceed? (y/N) ----->", x$
  1126.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  1127.     IF filename$ = "" THEN EXIT SUB
  1128.  
  1129.     numnotes = VAL(numnotes$)
  1130.     RANDOMIZE VAL(seed$)
  1131.     filename$ = filename$ + ".CEL"
  1132.  
  1133.     OPEN filename$ FOR OUTPUT AS #1
  1134.     FOR r = 1 TO numnotes
  1135.         PRINT #1, CHR$(INT(RND * 256));
  1136.     NEXT
  1137.     CLOSE
  1138. END SUB
  1139.  
  1140. FUNCTION Round$ (initial$, newnote1$, scaletype, size)
  1141.     'given the INITIAL$ notes, NEWNOTE1$ is frequency
  1142.     'quantized to make it harmonize with these notes
  1143.  
  1144.     available1$ = "c c+d d+e f f+g g+a a+b "
  1145.     octaves$ = "X:X" + CHR$(34) + "X'X x x'x" + CHR$(34) + "x:x;x=x*"
  1146.     
  1147.     'modify available$ to change key/scale
  1148.     SELECT CASE scaletype
  1149.         CASE 0  'chromatic
  1150.             available$ = "c c+d d+e f f+g g+a a+b "
  1151.         CASE 1  'whole tone starting on C
  1152.             available$ = "c   d   e   f+  g+  a+  "
  1153.         CASE 2  'whole tone starting on C+
  1154.             available$ = "  c+  d+  f   g   a   b "
  1155.         CASE 3  'diatonic/c-major
  1156.             available$ = "c   d   e f   g   a   b "
  1157.         CASE 4  'spooky
  1158.             available$ = "c   d d+  f   g g+  a+  "
  1159.         CASE 5  'black keys
  1160.             available$ = "  c+  d+    f+  g+  a+  "
  1161.         CASE 6  'indian
  1162.             available$ = "c c+  d+e   f+g   a a+  "
  1163.         CASE 7  'spooky/more diss
  1164.             available$ = "c   d d+e f f+g   a a+b "
  1165.         CASE ELSE
  1166.             available$ = "c c+d d+e f f+g g+a a+b "
  1167.     END SELECT
  1168.  
  1169.     'go through all the notes in initial$ and take out
  1170.     'all of their 'neighbors' in available$
  1171.     at = 0
  1172.     DO
  1173.         at = at + 1
  1174.         curnote1$ = GetWord$(initial$, at)
  1175.         IF curnote1$ = "" THEN EXIT DO
  1176.         curnote$ = LCASE$(MID$(curnote1$, 1, 1))
  1177.         IF INSTR(curnote1$, "+") THEN curnote$ = curnote$ + "+" ELSE curnote$ = curnote$ + " "
  1178.         x = INSTR(available1$, curnote$)
  1179.         FOR r = 1 TO size
  1180.             d1 = x - (2 * r)
  1181.             IF d1 < 1 THEN d1 = d1 + 24
  1182.             MID$(available$, d1, 2) = "  "
  1183.             d1 = x + (2 * r)
  1184.             IF d1 > 23 THEN d1 = d1 - 24
  1185.             MID$(available$, d1, 2) = "  "
  1186.         NEXT
  1187.     LOOP
  1188.  
  1189.     'now available$ has been cleared of clearly illegal
  1190.     'notes and can be scanned for best fit
  1191.  
  1192.     'make newnote1$ into a "featureless" note (newnote$)
  1193.     newnote$ = LCASE$(MID$(newnote1$, 1, 1))
  1194.     IF INSTR(newnote1$, "+") THEN newnote$ = newnote$ + "+" ELSE newnote$ = newnote$ + " "
  1195.  
  1196.     'make a string, three octaves long
  1197.     'if bottom octave, first string all spaces
  1198.     'if top octave, third string all spaces
  1199.     IF ASC(MID$(newnote1$, 1, 1)) < 72 AND INSTR(newnote1$, CHR$(34)) THEN s1$ = SPACE$(24) ELSE s1$ = available$
  1200.     IF INSTR(newnote1$, "*") THEN s3$ = SPACE$(24) ELSE s3$ = available$
  1201.     scan$ = s1$ + available$ + s3$
  1202.  
  1203.     'locate start point in second octave set
  1204.     startloc = INSTR(available1$, newnote$) + 24
  1205.  
  1206.     'check if note is already ok. if so, keep and exit
  1207.     IF Trim$(MID$(scan$, startloc, 2)) <> "" THEN
  1208.         Round$ = newnote1$
  1209.         EXIT FUNCTION
  1210.     END IF
  1211.  
  1212.     'scan up one, down one, until a non blank is hit
  1213.     offset = 2
  1214.     DO
  1215.         IF startloc + offset < LEN(scan$) THEN
  1216.             IF Trim$(MID$(scan$, startloc + offset, 2)) <> "" THEN
  1217.                 foundat = startloc + offset
  1218.                 GOTO found
  1219.             END IF
  1220.         END IF
  1221.         IF startloc - offset > 0 THEN
  1222.             IF Trim$(MID$(scan$, startloc - offset, 2)) <> "" THEN
  1223.                 foundat = startloc - offset
  1224.                 GOTO found
  1225.             END IF
  1226.         END IF
  1227.         offset = offset + 2
  1228.         IF offset > 100 THEN
  1229.             Round$ = "": EXIT FUNCTION
  1230.         END IF
  1231.     LOOP
  1232.  
  1233.     'when note is hit, grab octave, check for case change,
  1234.     'write new note, and exit
  1235.     '                   X:X"X'X x x'x"x:x;x=x*
  1236. found:
  1237.     IF ASC(MID$(newnote1$, 1, 1)) < 72 THEN octscan$ = "X" ELSE octscan$ = "x"
  1238.     IF RIGHT$(newnote1$, 1) <> "+" AND LEN(newnote1$) <> 1 THEN octscan$ = octscan$ + RIGHT$(newnote1$, 1) ELSE octscan$ = octscan$ + " "
  1239.     curoct = INSTR(octaves$, octscan$)
  1240.     IF foundat < 25 THEN
  1241.         curoct = curoct - 2
  1242.     ELSEIF foundat > 48 THEN
  1243.         curoct = curoct + 2
  1244.     END IF
  1245.     IF curoct < 1 THEN curoct = 1
  1246.     newnote$ = Trim$(MID$(scan$, foundat, 2))
  1247.     IF MID$(octaves$, curoct, 1) = "X" THEN newnote$ = UCASE$(newnote$)
  1248.     Round$ = Trim$(newnote$ + MID$(octaves$, curoct + 1, 1))
  1249.  
  1250. END FUNCTION
  1251.  
  1252. SUB Save
  1253.     'Save the sequence array
  1254.     x$ = DIR$("*.DGS")
  1255.     IF x$ <> "" THEN
  1256.         PRINT x$,
  1257.         DO
  1258.             x$ = DIR$
  1259.             IF x$ = "" THEN EXIT DO
  1260.             PRINT x$,
  1261.         LOOP
  1262.     END IF
  1263.     PRINT
  1264.  
  1265.     LINE INPUT "Filename (8 chars) -->", filename$
  1266.     filename$ = Trim$(filename$)
  1267.     IF filename$ = "" THEN EXIT SUB
  1268.     filename$ = filename$ + ".DGS"
  1269.     OPEN filename$ FOR OUTPUT AS #1
  1270.         FOR r1 = 1 TO 11
  1271.             PRINT ".";
  1272.             FOR r2 = 1 TO 3
  1273.                 FOR r3 = 0 TO 500
  1274.                     PRINT #1, MKI$(notes(r1, r2, r3));
  1275.                 NEXT
  1276.             NEXT
  1277.         NEXT
  1278.     CLOSE #1
  1279. END SUB
  1280.  
  1281. SUB SaveText (filename$)
  1282.     IF filename$ = "" THEN
  1283.         LINE INPUT "Filename (8 chars) -->", filename$
  1284.         filename$ = Trim$(filename$)
  1285.         IF filename$ = "" THEN EXIT SUB
  1286.         filename$ = filename$ + ".TXT"
  1287.     END IF
  1288.     
  1289.     OPEN filename$ FOR OUTPUT AS #1
  1290.  
  1291.     'find top timeloc
  1292.     top = 0
  1293.     FOR r = 1 TO 11
  1294.         topc = notes(r, 1, 0)
  1295.         IF topc <> 0 THEN
  1296.             topc = notes(r, 1, topc) + notes(r, 3, topc)
  1297.         END IF
  1298.         IF topc > top THEN top = topc
  1299.     NEXT
  1300.  
  1301.     REDIM last(1 TO 11)
  1302.     FOR c = 1 TO 11: last(c) = 0: NEXT
  1303.  
  1304.     IF filename$ <> "SEQ.TXT" THEN PRINT #1, "0-----1-----2-----3-----4-----5-----6-----7-----8-----9-----10---- 1"
  1305.     FOR t = 1 TO top
  1306.         temp$ = ""
  1307.         FOR c = 1 TO 11
  1308.             'check note starts at chan c, time t
  1309.             'check note ends at chan c, time t
  1310.             'or blank
  1311.             IF last(c) <= notes(c, 1, 0) THEN
  1312.                     sn = last(c) + 1
  1313.                     timeloc = notes(c, 1, sn)
  1314.                     noteend = notes(c, 1, last(c)) + notes(c, 3, last(c))
  1315.                     IF timeloc = t AND last(c) < notes(c, 1, 0) THEN
  1316.                         x$ = Num2Note$(notes(c, 2, sn))
  1317.                         n$ = "   "
  1318.                         LSET n$ = x$
  1319.                         temp$ = temp$ + n$
  1320.                         last(c) = last(c) + 1
  1321.                     ELSEIF noteend = t THEN
  1322.                         temp$ = temp$ + "***"
  1323.                     ELSE
  1324.                         temp$ = temp$ + "   "
  1325.                     END IF
  1326.                     IF filename$ <> "SEQ.TXT" THEN temp$ = temp$ + " | "
  1327.             ELSE
  1328.                 temp$ = temp$ + "***"
  1329.             END IF
  1330.         NEXT
  1331.         IF filename$ <> "SEQ.TXT" THEN temp$ = RTRIM$(temp$) + HEX$((t - 1) MOD 16)
  1332.         PRINT #1, temp$
  1333.         IF t MOD 16 = 0 THEN
  1334.             IF filename$ <> "SEQ.TXT" THEN PRINT #1, "0-----1-----2-----3-----4-----5-----6-----7-----8-----9-----10----"; ((t \ 16) + 1)
  1335.         END IF
  1336.     NEXT
  1337.     
  1338.     CLOSE #1
  1339.     ERASE last
  1340. END SUB
  1341.  
  1342. FUNCTION ScaleNum (initial, irlo, irhi, orlo, orhi, inv)
  1343.     'rescales an INITIAL number, range IRLO-IRHI to a
  1344.     'number in the range ORLO-ORHI. if boolean INV is
  1345.     'true, then the conversion is inverted
  1346.  
  1347.     top = irhi - irlo
  1348.     temp = initial - irlo   'temp is in range 0-top
  1349.  
  1350.     IF inv THEN temp = top - temp    'invert if needed
  1351.  
  1352.     newtop = orhi - orlo
  1353.  
  1354.     ScaleNum = orlo + ((newtop / top) * temp)
  1355. END FUNCTION
  1356.  
  1357. FUNCTION Trim$ (orig$)
  1358.     Trim$ = LTRIM$(RTRIM$(orig$))
  1359. END FUNCTION
  1360.  
  1361. SUB ViewComp
  1362.     'find top timeloc
  1363.     top = 0
  1364.     FOR r = 1 TO 11
  1365.         topc = notes(r, 1, 0)
  1366.         IF topc <> 0 THEN
  1367.             topc = notes(r, 1, topc) + notes(r, 3, topc)
  1368.         END IF
  1369.         IF topc > top THEN top = topc
  1370.     NEXT
  1371.     IF top = 0 THEN top = 640
  1372.     mult# = 639 / top
  1373.     PRINT mult#
  1374.  
  1375.     SCREEN 12
  1376.     FOR r = 0 TO 11
  1377.         LINE (0, (r * 24) + 5)-(639, (r * 24) + 5), 1
  1378.     NEXT
  1379.     FOR r = 1 TO top + 16 STEP 16
  1380.         r1 = (mult# * r) - 1
  1381.         LINE (r1, 5)-(r1, 269), 1
  1382.     NEXT
  1383.     LINE (639, 5)-(639, 269), 1
  1384.     
  1385.     FOR c = 1 TO 11
  1386.         col = 16 - c
  1387.         IF col < 9 THEN col = col - 1
  1388.         FOR n = 1 TO notes(c, 1, 0)
  1389.             r1 = (mult# * (notes(c, 1, n))) - 1
  1390.             r2 = (mult# * ((notes(c, 1, n)) + (notes(c, 3, n)) - 1)) - 1
  1391.             v = 250 - (notes(c, 2, n) * 2)
  1392.             LINE (r1, v)-(r2, v), col
  1393.         NEXT
  1394.     NEXT
  1395.     LOCATE 30, 1
  1396.     PRINT "--Press any key to return to menu--";
  1397.     
  1398.     DO UNTIL INKEY$ <> "": LOOP
  1399.     SCREEN 0
  1400. END SUB
  1401.  
  1402. FUNCTION VLen$ (f&)
  1403.     'This returns one of those CRAZY midi-style variable length
  1404.     'numbers: 7 bits per byte, all bytes except last one have bit 7 set,
  1405.     'last byte has bit 7 clear.
  1406.  
  1407.     first& = ((f& AND &HFE00000) \ &H200000) OR &H80
  1408.     second& = ((f& AND &H1FC000) \ &H4000) OR &H80
  1409.     third& = ((f& AND &H3F80) \ &H80) OR &H80
  1410.     last& = f& AND &H7F
  1411.  
  1412.     IF first& = &H80 THEN
  1413.         IF second& = &H80 THEN
  1414.             IF third& = &H80 THEN  'one byte
  1415.                 v$ = CHR$(last&)
  1416.             ELSE    'two byte
  1417.                 v$ = CHR$(third&) + CHR$(last&)
  1418.             END IF
  1419.         ELSE    'three byte
  1420.             v$ = CHR$(second&) + CHR$(third&) + CHR$(last&)
  1421.         END IF
  1422.     ELSE    'four byte
  1423.         v$ = CHR$(first&) + CHR$(second&) + CHR$(third&) + CHR$(last&)
  1424.     END IF
  1425.  
  1426.     VLen$ = v$
  1427.  
  1428.  
  1429. END FUNCTION
  1430.  
  1431. SUB Wave
  1432.     CLS
  1433.     PRINT "Dilaudid Glide"
  1434.     PRINT "Music Authoring System             (  X: X" + CHR$(34) + " X' X x x' x" + CHR$(34) + " x: x; x= x* )"
  1435.     PRINT STRING$(80, "-")
  1436.     PRINT
  1437.     PRINT "Wave type:"
  1438.     PRINT "   /     \         /\          -"
  1439.     PRINT "  /|     |\       /  \       /   \"
  1440.     PRINT " / |     | \     /    \     |     |"
  1441.     PRINT "/  |     |  \   /      \  _/       \_"
  1442.     PRINT "1.UP     2.DN   3.TRI      4.SINE"
  1443.     PRINT
  1444.     LINE INPUT "Wave type ---------->", WaveType$
  1445.     LINE INPUT "Notes/cycle -------->", notesper$
  1446.     LINE INPUT "Number of cycles --->", nocycles$
  1447.     LINE INPUT "Filename (8 chars) ->", filename$
  1448.     PRINT
  1449.     LINE INPUT "Proceed? (y/N) ----->", x$
  1450.     IF LCASE$(LEFT$(x$, 1)) <> "y" THEN EXIT SUB
  1451.     IF filename$ = "" THEN EXIT SUB
  1452.  
  1453.     WaveType = VAL(WaveType$)
  1454.     notesper = VAL(notesper$)
  1455.     nocycles = VAL(nocycles$)
  1456.     filename$ = filename$ + ".CEL"
  1457.  
  1458.     OPEN filename$ FOR OUTPUT AS #1
  1459.  
  1460.     FOR c = 1 TO nocycles
  1461.         SELECT CASE WaveType
  1462.             CASE 1  'up triangle wave
  1463.                 FOR n = 1 TO notesper
  1464.                     x = ScaleNum(n, 1, notesper, 0, 255, 0)
  1465.                     PRINT #1, CHR$(x);
  1466.                 NEXT
  1467.             CASE 2  'down triangle wave
  1468.                 FOR n = notesper TO 1 STEP -1
  1469.                     x = ScaleNum(n, 1, notesper, 0, 255, 0)
  1470.                     PRINT #1, CHR$(x);
  1471.                 NEXT
  1472.             CASE 3  'full triangle wave
  1473.                 n2 = notesper \ 2
  1474.                 FOR n = 1 TO n2
  1475.                     x = ScaleNum(n, 1, n2, 0, 255, 0)
  1476.                     PRINT #1, CHR$(x);
  1477.                 NEXT
  1478.                 r1 = ScaleNum(2, 1, n2, 0, 255, 0)
  1479.                 r2 = ScaleNum(n2 - 1, 1, n2, 0, 255, 0)
  1480.                 FOR n = (notesper \ 2) TO 1 STEP -1
  1481.                     x = ScaleNum(n, 1, n2, r1, r2, 0)
  1482.                     PRINT #1, CHR$(x);
  1483.                 NEXT
  1484.             CASE 4  'sine wave
  1485.                 FOR n = 1 TO notesper
  1486.                     n2# = ((n - 1) / (notesper - 1)) * 6.2
  1487.                     x2# = SIN(n2#)
  1488.                     x = (x2# + 1) * 127
  1489.                     PRINT #1, CHR$(x);
  1490.                 NEXT
  1491.         END SELECT
  1492.     NEXT
  1493.  
  1494.     CLOSE
  1495. END SUB
  1496.  
  1497. FUNCTION words (text$)
  1498.         temp = 1
  1499.         FOR r = 1 TO LEN(text$)
  1500.             IF MID$(text$, r, 1) = " " THEN temp = temp + 1
  1501.         NEXT
  1502.         words = temp
  1503. END FUNCTION
  1504.  
  1505. SUB WriteTrack (name$, data$, fhand)
  1506.     PRINT #fhand, "MTrk" + mkl2$(LEN(data$) + LEN(name$) + 8);
  1507.     PRINT #fhand, CHR$(0) + CHR$(&HFF) + CHR$(3) + CHR$(LEN(name$)) + name$;
  1508.     PRINT #fhand, data$;
  1509.     PRINT #fhand, CHR$(&H0) + CHR$(&HFF) + CHR$(&H2F) + CHR$(0);
  1510. END SUB
  1511.  
  1512.